(GLOBAL 
  (FUNCTIONS TRY-NEXT NOTE ADIEU AU-REVOIR INSTANCE GET-POSSIBILITIES
   SET-POSSIBILITIES GENERATE)
  (RESERVED *IGNORE *ITEM *NOTE *METHOD *GENERATOR *AU-REVOIR *BLOCK *POSSIBILITIES))

(DECLARE   (SYMBOLS T) (GENPREFIX \T) (GENSYM 'T) 
 (SPECIAL TEM TEM1 TEM2 ALINK BVARS EXP CLINK FRAME* VAL)
 (*FEXPR CERR INSTANCE PROPOSE /,)
 (*LEXPR CSET VFRAME ACCESS CONTROL))

(DEFUN ALINK MACRO (L) (LIST 'CDADR (CADR L)))

(DEFUN CLINK MACRO (L) (LIST 'CDDDR (CADR L)))

(CDEFUN TRY-NEXT (POSSIBILITIES "OPTIONAL" (NOMORE NIL) (MESSAGE NIL))
   "AUX" (POS)
   (/: TRY-NEXT) (GO (NEXT))
   (/: EXIT) (RETURN (CEVAL NOMORE (ACCESS)))
   (/: RETURN) (RETURN POS)
   (/: *METHOD) (METGO)
   (/: *GENERATOR) (GENGO)
   (/: *AU-REVOIR) (REGO)
   (/: *BLOCK) (TBLOCK))

(DEFUN NEXT FEXPR (L)
   (SETQ L (/, POSSIBILITIES))
   (COND ((OR (ATOM L) (NOT (EQ (CAAR L) '*POSSIBILITIES)))
          (CERR BAD POSSIBILITIES LIST)))
   (PROG (P)
         (COND ((NULL (CDR L)) (RETURN 'EXIT)))
         (UNBLOCK (CDR L))
    TN   (RPLACD L (CDDR L))
         (COND ((NULL (CDR L)) (RETURN 'EXIT))
               ((EQ (SETQ P (CADR L)) '*IGNORE) (GO TN))
               ((ATOM P) (CSET 'POS P) (RETURN 'RETURN))
               ((EQ (CAR P) '*ITEM)
                (SETUP (CADDR P))
                (CSET 'POS (CADR P))
                (RETURN 'RETURN))
               ((EQ (CAR P) '*NOTE)
                (SETUP (CADR P))
                (CSET 'POS P)
                (RETURN 'RETURN))
               ((MEMQ (CAR P) '(*METHOD *GENERATOR *AU-REVOIR *BLOCK))
                (RETURN (CAR P)))
               (T (CSET 'POS P) (RETURN 'RETURN)))))

(DEFUN SETUP (ALIST)
   (SETQ TEM (ACCESS))
   (MAPC '(LAMBDA (PAIR) (CSET (CAR PAIR) (CADR PAIR) TEM)) ALIST))

(DEFUN GENGO ()
 (SETQ TEM (CDR (IVAL 'POSSIBILITIES ALINK))
       BVARS (LIST (LIST 'NEXT TEM))
       CLINK (FR (TAG 'TRY-NEXT))
       ALINK (ALINK CLINK)
       TEM1 (CADAR TEM)
       FRAME* NIL)
 (RPLACA TEM (LIST '*BLOCK))
 (DISPATCH TEM1 'POPJ () '*TOP))
(DEFPROP GENGO GENGO CINT)

(DEFUN METGO ()
 (SETQ TEM (CDR (IVAL 'POSSIBILITIES ALINK))
       TEM1 (CADAR TEM)
       BVARS (NCONC (LIST (LIST 'NEXT TEM)
                          (LIST '*BODY (TEXT TEM1))
                          (LIST '*CALLPAT (CADDDR (CDAR TEM)))
                          (LIST '*METHPAT (PATTERN TEM1))
                          (LIST '*CALLALIST (CADDDR (CAR TEM)))
                          (LIST '*METHALIST (CADDAR TEM)))
                    (CADDAR TEM))
       EXP (LIST TEM1 (CADDDR (CDAR TEM)))
       FRAME* NIL
       CLINK (FR (TAG 'TRY-NEXT))
       ALINK (ALINK CLINK))
 (CLOSE)
 (RPLACA TEM (LIST '*BLOCK)) 
 'AUXB)
(DEFPROP METGO METGO CINT)

(DEFUN REGO ()
 (SETQ TEM (CDR (IVAL 'POSSIBILITIES ALINK))
       VAL (IVAL 'MESSAGE ALINK)
       FRAME* (CADAR TEM))
 (SETCONTROL (VFRAME 'NEXT (CAR TEM)) (TAG 'TRY-NEXT))
 (CSET 'NEXT TEM (CAR TEM))
 (RPLACA TEM (LIST '*BLOCK))
 (RESTORE))
(DEFPROP REGO REGO CINT)

(CDEFUN TBLOCK ()
  (NCONC (CADR POSSIBILITIES) (TAG 'TRY-NEXT))
  (ALLOW NIL)
  (COND ((/@ . READY) (CONTINUE (/@ PROG2 (ALLOW T) (CAR READY) (SETQ READY (CDR READY))))))
  (ALLOW T)
  (LISTEN 'ALL-BLOCKED-UP))

(DEFUN UNBLOCK (L)
  (COND ((EQ (CAAR L) '*BLOCK)
         (NCONC (GET 'READY 'VALUE) (CDAR L))
         (RPLACA L '*IGNORE))))

(DEFUN NOTE N
 (COND ((= N 0) 
        ((LAMBDA (P) (COND (P (ENTER P))))
         (INSTANCE))
        0)
       (T (PROG (NEXT M)
                (SETQ M 0 NEXT (CDR (VLOC 'NEXT)))
           LP (COND ((> (SETQ M (ADD1 M)) N) (RETURN N)))
              (RPLACD (CAR NEXT) (CONS (ARG M)(CDAR NEXT)))
              (RPLACA NEXT (CDAR NEXT))
              (GO LP)))))

(CDEFUN ADIEU ("REST" L) (PROPOSE) (DISMISS (VFRAME 'NEXT)))

(CDEFUN AU-REVOIR ("REST" L) (PROPOSE) 
   (ENTER (CONS '*AU-REVOIR (CDR (CONTROL))))
   (DISMISS (VFRAME 'NEXT)))

(DEFUN ENTER (X)
   (SETQ TEM (CDR (VLOC 'NEXT)))
   (RPLACD (CAR TEM) (CONS X (CDAR TEM)))
   (RPLACA TEM (CDAR TEM)))

(DEFUN PROPOSE FEXPR (L)
   (SETQ L (CDR (VLOC 'NEXT)))
   (MAPC '(LAMBDA (X) 
              (RPLACD (CAR L) (CONS X (CDAR L)))
              (RPLACA L (CDAR L)))
         (/, L)))

(DEFUN INSTANCE FEXPR (L)
 (PROG (NEXTF CALLA)
   (SETQ NEXTF (FR (VFRAME 'NEXT))
         CALLA (IVAL '*CALLALIST NEXTF)
         L (MATCH (IVAL '*CALLPAT NEXTF)
                    (IVAL '*METHPAT NEXTF)
                    CALLA
                    (IVAL '*METHALIST NEXTF)))
   (COND (L (RETURN (LIST '*NOTE (CPY (CAR L))))))))

(DEFUN CPY (L) (MAPCAR '(LAMBDA (X) (LIST (CAR X)(CADR X))) L))

(DEFUN GET-POSSIBILITIES FEXPR () (IVAL 'POSSIBILITIES (CLINK (FR (VFRAME 'NEXT))
)))

(DEFUN SET-POSSIBILITIES (LIST) (CSET 'POSSIBILITIES LIST (CONTROL (VFRAME 'NEXT)
)))

(CDEFUN GENERATE ('FORM) "AUX" ((POSSIBILITIES
                                  (LIST (LIST '*POSSIBILITIES FORM)
                                        (LIST '*GENERATOR FORM))))
    (GENGO)
  (/: TRY-NEXT)
    POSSIBILITIES)